home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
c
/
typespec.c
< prev
next >
Wrap
C/C++ Source or Header
|
1987-06-04
|
13KB
|
596 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
typespec.c
type specifier routines
*/
#include "include.h"
object
St, Snil, Scommon,
Snull, Scons, Slist, Ssymbol,
Sarray, Svector, Sbit_vector, Sstring,
Ssequence,
Ssimple_array, Ssimple_vector, Ssimple_bit_vector,
Ssimple_string,
Sfunction, Scompiled_function,
Spathname, Scharacter,
Snumber, Srational, Sfloat, Sstring_char,
Sinteger, Sratio, Sshort_float, Sstandard_char,
Sfixnum, Scomplex, Ssingle_float, Spackage,
Sbignum, Srandom_state, Sdouble_float, Sstream,
Sbit, Sreadtable, Slong_float, Shash_table;
object Skeyword;
object Sstructure;
object Ssatisfies;
object Smember;
object Snot;
object Sor;
object Sand;
object Svalues;
object Smod;
object Ssigned_byte;
object Sunsigned_byte;
object SA; /* symbol * */
object TSor_symbol_string;
object TSor_string_symbol;
object TSor_symbol_string_package;
object TSnon_negative_integer;
object TSor_integer_float;
object TSor_rational_float;
#ifdef UNIX
object TSor_pathname_string_symbol;
#endif
object TSor_pathname_string_symbol_stream;
check_type_integer(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_fixnum && t != t_bignum)
*p = wrong_type_argument(Sinteger, *p);
}
check_type_non_negative_integer(p)
object *p;
{
enum type t;
for (;;) {
t = type_of(*p);
if (t == t_fixnum) {
if (fix((*p)) >= 0)
break;
} else if (t == t_bignum) {
if (big_sign((struct bignum *)(*p)) >= 0)
break;
}
*p = wrong_type_argument(TSnon_negative_integer, *p);
}
}
check_type_rational(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_fixnum &&
t != t_bignum && t != t_ratio)
*p = wrong_type_argument(Srational, *p);
}
check_type_float(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_shortfloat && t != t_longfloat)
*p = wrong_type_argument(Sfloat, *p);
}
check_type_or_integer_float(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
t != t_shortfloat && t != t_longfloat)
*p = wrong_type_argument(TSor_integer_float, *p);
}
check_type_or_rational_float(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
t != t_ratio && t != t_shortfloat && t != t_longfloat)
*p = wrong_type_argument(TSor_rational_float, *p);
}
check_type_number(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_fixnum && t != t_bignum &&
t != t_ratio && t != t_shortfloat && t != t_longfloat &&
t != t_complex)
*p = wrong_type_argument(Snumber, *p);
}
check_type_bit(p)
object *p;
{
while (type_of(*p) != t_fixnum ||
fix((*p)) != 0 && fix((*p)) != 1)
*p = wrong_type_argument(Sbit, *p);
}
check_type_character(p)
object *p;
{
while (type_of(*p) != t_character)
*p = wrong_type_argument(Scharacter, *p);
}
check_type_string_char(p)
object *p;
{
while (type_of(*p) != t_character ||
char_font((*p)) != 0 ||
char_bits((*p)) != 0)
*p = wrong_type_argument(Scharacter, *p);
}
check_type_symbol(p)
object *p;
{
while (type_of(*p) != t_symbol)
*p = wrong_type_argument(Ssymbol, *p);
}
check_type_or_symbol_string(p)
object *p;
{
while (type_of(*p) != t_symbol && type_of(*p) != t_string)
*p = wrong_type_argument(TSor_symbol_string, *p);
}
check_type_or_string_symbol(p)
object *p;
{
while (type_of(*p) != t_symbol && type_of(*p) != t_string)
*p = wrong_type_argument(TSor_string_symbol, *p);
}
check_type_or_symbol_string_package(p)
object *p;
{
while (type_of(*p) != t_symbol &&
type_of(*p) != t_string &&
type_of(*p) != t_package)
*p = wrong_type_argument(TSor_symbol_string_package,
*p);
}
check_type_package(p)
object *p;
{
while (type_of(*p) != t_package)
*p = wrong_type_argument(Spackage, *p);
}
check_type_string(p)
object *p;
{
while (type_of(*p) != t_string)
*p = wrong_type_argument(Sstring, *p);
}
check_type_bit_vector(p)
object *p;
{
while (type_of(*p) != t_bitvector)
*p = wrong_type_argument(Sbit_vector, *p);
}
check_type_cons(p)
object *p;
{
while (type_of(*p) != t_cons)
*p = wrong_type_argument(Scons, *p);
}
check_type_stream(p)
object *p;
{
while (type_of(*p) != t_stream)
*p = wrong_type_argument(Sstream, *p);
}
check_type_readtable(p)
object *p;
{
while (type_of(*p) != t_readtable)
*p = wrong_type_argument(Sreadtable, *p);
}
#ifdef UNIX
check_type_or_Pathname_string_symbol(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_pathname &&
t != t_string && t != t_symbol)
*p = wrong_type_argument(
TSor_pathname_string_symbol, *p);
}
#endif
check_type_or_pathname_string_symbol_stream(p)
object *p;
{
enum type t;
while ((t = type_of(*p)) != t_pathname &&
t != t_string && t != t_symbol && t != t_stream)
*p = wrong_type_argument(
TSor_pathname_string_symbol_stream, *p);
}
check_type_random_state(p)
object *p;
{
while (type_of(*p) != t_random)
*p = wrong_type_argument(Srandom_state, *p);
}
check_type_hash_table(p)
object *p;
{
while (type_of(*p) != t_hashtable)
*p = wrong_type_argument(Shash_table, *p);
}
check_type_array(p)
object *p;
{
BEGIN:
switch (type_of(*p)) {
case t_array:
case t_vector:
case t_string:
case t_bitvector:
return;
default:
*p = wrong_type_argument(Sarray, *p);
goto BEGIN;
}
}
check_type_vector(p)
object *p;
{
BEGIN:
switch (type_of(*p)) {
case t_vector:
case t_string:
case t_bitvector:
return;
default:
*p = wrong_type_argument(Svector, *p);
goto BEGIN;
}
}
Ltype_of()
{
int i;
check_arg(1);
switch (type_of(vs_base[0])) {
case t_fixnum:
vs_base[0] = Sfixnum;
break;
case t_bignum:
vs_base[0] = Sbignum;
break;
case t_ratio:
vs_base[0] = Sratio;
break;
case t_shortfloat:
vs_base[0] = Sshort_float;
break;
case t_longfloat:
vs_base[0] = Slong_float;
break;
case t_complex:
vs_base[0] = Scomplex;
break;
case t_character:
if (char_font(vs_base[0]) != 0
|| char_bits(vs_base[0]) != 0)
vs_base[0] = Scharacter;
else {
i = char_code(vs_base[0]);
if (' ' <= i && i < '\177' || i == '\n')
vs_base[0] = Sstandard_char;
else
vs_base[0] = Sstring_char;
}
break;
case t_symbol:
if (vs_base[0]->s.s_hpack == keyword_package)
vs_base[0] = Skeyword;
else
vs_base[0] = Ssymbol;
break;
case t_package:
vs_base[0] = Spackage;
break;
case t_cons:
vs_base[0] = Scons;
break;
case t_hashtable:
vs_base[0] = Shash_table;
break;
case t_array:
if (vs_base[0]->a.a_adjustable ||
vs_base[0]->a.a_displaced->c.c_car == Cnil)
vs_base[0] = Sarray;
else
vs_base[0] = Ssimple_array;
break;
case t_vector:
if (vs_base[0]->v.v_adjustable ||
vs_base[0]->v.v_hasfillp ||
vs_base[0]->v.v_displaced->c.c_car == Cnil ||
(enum aelttype)vs_base[0]->v.v_elttype != aet_object)
vs_base[0] = Svector;
else
vs_base[0] = Ssimple_vector;
break;
case t_string:
if (vs_base[0]->st.st_adjustable ||
vs_base[0]->st.st_hasfillp ||
vs_base[0]->st.st_displaced->c.c_car == Cnil)
vs_base[0] = Sstring;
else
vs_base[0] = Ssimple_string;
break;
case t_bitvector:
if (vs_base[0]->bv.bv_adjustable ||
vs_base[0]->bv.bv_hasfillp ||
vs_base[0]->bv.bv_displaced->c.c_car == Cnil)
vs_base[0] = Sbit_vector;
else
vs_base[0] = Ssimple_bit_vector;
break;
case t_structure:
vs_base[0] = vs_base[0]->str.str_name;
break;
case t_stream:
vs_base[0] = Sstream;
break;
case t_readtable:
vs_base[0] = Sreadtable;
break;
case t_pathname:
vs_base[0] = Spathname;
break;
case t_random:
vs_base[0] = Srandom_state;
break;
case t_cfun:
case t_cclosure:
vs_base[0] = Scompiled_function;
break;
default:
error("not a lisp data object");
}
}
init_typespec()
{
St = make_ordinary("T");
enter_mark_origin(&St);
Snil = make_ordinary("NIL");
enter_mark_origin(&Snil);
Scommon = make_ordinary("COMMON");
enter_mark_origin(&Scommon);
Snull = make_ordinary("NULL");
enter_mark_origin(&Snull);
Scons = make_ordinary("CONS");
enter_mark_origin(&Scons);
Slist = make_ordinary("LIST");
enter_mark_origin(&Slist);
Ssymbol = make_ordinary("SYMBOL");
enter_mark_origin(&Ssymbol);
Sarray = make_ordinary("ARRAY");
enter_mark_origin(&Sarray);
Svector = make_ordinary("VECTOR");
enter_mark_origin(&Svector);
Sbit_vector = make_ordinary("BIT-VECTOR");
enter_mark_origin(&Sbit_vector);
Sstring = make_ordinary("STRING");
enter_mark_origin(&Sstring);
Ssequence = make_ordinary("SEQUENCE");
enter_mark_origin(&Ssequence);
Ssimple_array = make_ordinary("SIMPLE-ARRAY");
enter_mark_origin(&Ssimple_array);
Ssimple_vector = make_ordinary("SIMPLE-VECTOR");
enter_mark_origin(&Ssimple_vector);
Ssimple_bit_vector = make_ordinary("SIMPLE-BIT-VECTOR");
enter_mark_origin(&Ssimple_bit_vector);
Ssimple_string = make_ordinary("SIMPLE-STRING");
enter_mark_origin(&Ssimple_string);
Sfunction = make_ordinary("FUNCTION");
enter_mark_origin(&Sfunction);
Scompiled_function = make_ordinary("COMPILED-FUNCTION");
enter_mark_origin(&Scompiled_function);
Spathname = make_ordinary("PATHNAME");
enter_mark_origin(&Spathname);
Scharacter = make_ordinary("CHARACTER");
enter_mark_origin(&Scharacter);
Snumber = make_ordinary("NUMBER");
enter_mark_origin(&Snumber);
Srational = make_ordinary("RATIONAL");
enter_mark_origin(&Srational);
Sfloat = make_ordinary("FLOAT");
enter_mark_origin(&Sfloat);
Sstring_char = make_ordinary("STRING-CHAR");
enter_mark_origin(&Sstring_char);
Sinteger = make_ordinary("INTEGER");
enter_mark_origin(&Sinteger);
Sratio = make_ordinary("RATIO");
enter_mark_origin(&Sratio);
Sshort_float = make_ordinary("SHORT-FLOAT");
enter_mark_origin(&Sshort_float);
Sstandard_char = make_ordinary("STANDARD-CHAR");
enter_mark_origin(&Sstandard_char);
Sfixnum = make_ordinary("FIXNUM");
enter_mark_origin(&Sfixnum);
Scomplex = make_ordinary("COMPLEX");
enter_mark_origin(&Scomplex);
Ssingle_float = make_ordinary("SINGLE-FLOAT");
enter_mark_origin(&Ssingle_float);
Spackage = make_ordinary("PACKAGE");
enter_mark_origin(&Spackage);
Sbignum = make_ordinary("BIGNUM");
enter_mark_origin(&Sbignum);
Srandom_state = make_ordinary("RANDOM-STATE");
enter_mark_origin(&Srandom_state);
Sdouble_float = make_ordinary("DOUBLE-FLOAT");
enter_mark_origin(&Sdouble_float);
Sstream = make_ordinary("STREAM");
enter_mark_origin(&Sstream);
Sbit = make_ordinary("BIT");
enter_mark_origin(&Sbit);
Sreadtable = make_ordinary("READTABLE");
enter_mark_origin(&Sreadtable);
Slong_float = make_ordinary("LONG-FLOAT");
enter_mark_origin(&Slong_float);
Shash_table = make_ordinary("HASH-TABLE");
enter_mark_origin(&Shash_table);
Skeyword = make_ordinary("KEYWORD");
enter_mark_origin(&Skeyword);
Sstructure = make_ordinary("STRUCTURE");
enter_mark_origin(&Sstructure);
Ssatisfies = make_ordinary("SATISFIES");
enter_mark_origin(&Ssatisfies);
Smember = make_ordinary("MEMBER");
enter_mark_origin(&Smember);
Snot = make_ordinary("NOT");
enter_mark_origin(&Snot);
Sor = make_ordinary("OR");
enter_mark_origin(&Sor);
Sand = make_ordinary("AND");
enter_mark_origin(&Sand);
Svalues = make_ordinary("VALUES");
enter_mark_origin(&Svalues);
Smod = make_ordinary("MOD");
enter_mark_origin(&Smod);
Ssigned_byte = make_ordinary("SIGNED-BYTE");
enter_mark_origin(&Ssigned_byte);
Sunsigned_byte = make_ordinary("UNSIGNED-BYTE");
enter_mark_origin(&Sunsigned_byte);
SA = make_ordinary("*");
enter_mark_origin(&SA);
}
init_typespec_function()
{
TSor_symbol_string
= make_cons(Sor, make_cons(Ssymbol, make_cons(Sstring, Cnil)));
enter_mark_origin(&TSor_symbol_string);
TSor_string_symbol
= make_cons(Sor, make_cons(Sstring, make_cons(Ssymbol, Cnil)));
enter_mark_origin(&TSor_string_symbol);
TSor_symbol_string_package
= make_cons(Sor,
make_cons(Ssymbol,
make_cons(Sstring,
make_cons(Spackage, Cnil))));
enter_mark_origin(&TSor_symbol_string_package);
TSnon_negative_integer
= make_cons(Sinteger,
make_cons(make_fixnum(0), make_cons(SA, Cnil)));
enter_mark_origin(&TSnon_negative_integer);
TSor_integer_float
= make_cons(Sor, make_cons(Sinteger, make_cons(Sfloat, Cnil)));
enter_mark_origin(&TSor_integer_float);
TSor_rational_float
= make_cons(Sor, make_cons(Srational, make_cons(Sfloat, Cnil)));
enter_mark_origin(&TSor_rational_float);
#ifdef UNIX
TSor_pathname_string_symbol
= make_cons(Sor,
make_cons(Spathname,
make_cons(Sstring,
make_cons(Ssymbol,
Cnil))));
enter_mark_origin(&TSor_pathname_string_symbol);
#endif
TSor_pathname_string_symbol_stream
= make_cons(Sor,
make_cons(Spathname,
make_cons(Sstring,
make_cons(Ssymbol,
make_cons(Sstream,
Cnil)))));
enter_mark_origin(&TSor_pathname_string_symbol_stream);
make_function("TYPE-OF", Ltype_of);
}